Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/cursor/cursor.bas

BASIC Source File | 1995-05-09 | 6KB | 155 lines

Option Explicit

' Demo by Pierre Fillion (c) 1993 by Synetics Consultation
' Version 1.1 - 1993/05/10
' (FEEL FREE TO DISTRIBUTE THE ENTIRE ARCHIVE ONLY WITHOUT MODIFICATIONS)

' I don't ask for any contributions, you may use theses routines freely
' but, it you release a .vbx or shareware routines, it would be nice
' to send me a registred copy.

' %%% Special thanks to David Sainsbury for the main routines
' %%% Very Special thanks to Fred Egger for his help to my color problem

'       Any suggestions ? or improvments ?
'       Please drop me a line on CIS 71162,51
'       or to :
'                Pierre Fillion
'                8460 Perras #1
'                Montreal,Quebec
'                H1E 5C7

'  Thanks a lot.

'------------------------------------------------------------------------
' Follow theses steps...
'------------------------------------------------------------------------

' Simply add the cursor.bas module to your project.

' Create a picture box (32x32 pixel) for the cursor and an inverted
' picture box of the first one. (See the .ico included with this demo)
' -- Use IconWorks that comes with VB or anyother, to create your pictures.
' -- Don't forget to had a light red pixel to define a hotspot in the icon.

' ******************************* NOTICE ********************************
' ******* (The inverted picture is the original one with white color
' *******  changed to screen color and everything else to white)
' ***********************************************************************

' Use the SetCursor to create the cursor,

' Use RestoreCursor to restore it back to what it was.

'------------------------------------------------------------------------

' Function SetCursor (hWnd As Integer, CursorPic As Control,
'                                      CursorPicX As Control) As Integer

' -- hWnd : Handle of the window or control where the cursor will change.
' -- CursorPic  : Name of the control holding the icon previously created.
'                 Ex:(Picture1)
' -- CursorPicX : Name of the control holding the inverted icon of CursorPic.
'                 Ex:(Picture2)


' Return the handle of the new cursor to be used in RemoveCursor.

' (This routine will call the hotspot routine to find the light red pixel
'  position in CursorPic and set the hotspot.)

'------------------------------------------------------------------------
' Sub RestoreCursor (hWnd As Integer, OldCursor As Integer)

' -- hWnd : Handle of the window or control specified in SetCursor
' -- OldCursor : Variable containing the handle returned by SetCursor

'========================================================================

'------------------------------------------------------------------------
'CURSOR.BAS Declarations
'------------------------------------------------------------------------

Declare Function GlobalLock Lib "Kernel" (ByVal hMem As Integer) As Long
Declare Function GlobalUnLock Lib "Kernel" (ByVal hMem As Integer) As Integer
Declare Function CreateCursor Lib "User" (ByVal hInstance%, ByVal nXhotspot%, ByVal nYhotspot%, ByVal nWidth%, ByVal nHeight%, ByVal lpANDbitPlane As Any, ByVal lpXORbitPlane As Any) As Integer
Declare Function GetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer
Declare Function SetClassWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer, ByVal nNewWord As Integer) As Integer
Declare Function GetClassWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer
Declare Function GetBitmapBits Lib "Gdi" (ByVal hBitmap As Integer, ByVal dwCount As Long, ByVal lpbits As String) As Long

Global Const GCW_HCURSOR = -12
Global Const GWW_HINSTANCE = -6

Sub GetHotSpot (CursorPic As Control, xhs As Integer, yhs As Integer)

    Dim Ret As Long
    Dim lpbits As String * 1024
    Dim bits As Integer

    'Retrieve the cursor bits to check for the hotspot (x,y)
    bits = Val(CursorPic.Image)
    Ret = GetBitmapBits(bits, 1024, lpbits)
    yhs = 0
    xhs = 0

    'Find the red pixel x,y position for hotspot location
    For bits = 1 To 1024
        If Mid$(lpbits, bits, 1) = "∙" Then
            yhs = Int(bits / 32) + 1
            xhs = bits - ((yhs - 1) * 32)
        End If
    Next bits

End Sub

Sub RestoreCursor (hWnd As Integer, OldCursor As Integer)

    Dim Ret As Integer

    Ret = SetClassWord(hWnd, GCW_HCURSOR, OldCursor)

End Sub

Function SetCursor (hWnd As Integer, CursorPic As Control, CursorPicX As Control) As Integer

    Dim ghInstance As Integer
    Dim lpand As Long, lpandx As Long
    Dim Ret As Integer
    Dim hNewCursor As Integer
    Dim hotx As Integer
    Dim hoty As Integer

    'Set the hotspot by retrieving the location of the first
    'picture containing the red pixel
    Call GetHotSpot(CursorPic, hotx, hoty)

    'CursorPic  is a picture box control with a 32x32 pixels mono bitmap
    'CursorPicX is an inverted picture box control of the first CursorPic

    'The First Picture must contain a light red dot for the hotspot position

    '(The CursorPicX is created to allow white & background to be defined ok)
    '(Refer of the .ico files incloded to see how to do it for other cursors)

    'hWnd is the handle of the window or control to apply the new cursor to

    'Retreive window or control instance and pictures adresses
    SetCursor = GetClassWord(hWnd, GCW_HCURSOR)
    ghInstance = GetWindowWord(hWnd, GWW_HINSTANCE)
    lpand = GlobalLock(CursorPic.Picture)
    lpandx = GlobalLock(CursorPicX.Picture)

    'Set the cursor
    hNewCursor = CreateCursor(ghInstance, hotx, hoty, 32, 32, lpand + 12, lpandx + 12)

    'Free memory
    Ret = GlobalUnLock(CursorPic.Picture)
    Ret = GlobalUnLock(CursorPicX.Picture)

    'Apply the cursor to the window or control defined by hWnd
    Ret = SetClassWord(hWnd, GCW_HCURSOR, hNewCursor)

End Function